Power Programmierung/Power-Programmierung (Tewi)(1994).iso/magazine/pctchnqs/1990/number3/stackmon.pas

Pascal/Delphi Source File | 1990-02-22 | 6KB | 195 lines

{**********************************************************
  STACKMON.PAS -- By Brian Foley
  Self-activated unit for monitoring stack and heap usage.
  Works with Turbo Pascal 4.0, 5.0, and 5.5.
***********************************************************}

{$S-,R-,I-,B-,D-}

unit StackMon;
  {-Unit for monitoring stack and heap usage}

interface

uses
  Dos;

const
  {If ReportStackUsage is True, results are reported automatically
   at the end of the program. Set it to False if you want to display
   results in another manner.}
  ReportStackUsage : Boolean = True;

var
  {The following variables, like the two procedures that follow, are
   interfaced solely for the purpose of displaying results. You
   should never alter any of these variables.}
  OurSS : Word;         {value of SS register when program began}
  InitialSP : Word;     {value of SP register when program began}
  LowestSP : Word;      {lowest value for SP register}
  HeapHigh : Pointer;   {highest address pointed to by HeapPtr}

procedure CalcStackUsage(var StackUsage : Word;
                         var HeapUsage : LongInt);
  {-Calculate stack and heap usage}

procedure ShowStackUsage;
  {-Display stack and heap usage information}

{The next two routines are interfaced in case you need or want to
 deinstall the INT $8 handler temporarily, as you might when using
 the Exec procedure in the DOS unit.}

procedure InstallInt8;
  {-Save INT $8 vector and install our ISR}

procedure RestoreInt8;
  {-Restore the old INT $8 handler if our ISR is installed}

  {==========================================================================}

implementation

type
  SegOfs =                   {structure of a 32-bit pointer}
    record
      Ofst, Segm : Word;
    end;
var
  SaveInt8 : Pointer;        {original INT $8 vector}
  SaveExitProc : Pointer;    {saved value for ExitProc}
const
  {True if our INT $8 handler is installed}
  Int8Installed : Boolean = False;

  procedure JumpToOldIsr(OldIsr : Pointer);
    {-Jump to previous ISR from an interrupt procedure}
    inline(
      $5B/         {pop bx          ;bx = Ofs(OldIsr)}
      $58/         {pop ax          ;ax = Seg(OldIsr)}
      $87/$5E/$0E/ {xchg bx,[bp+14] ;Switch old bx and Ofs(OldIsr^)}
      $87/$46/$10/ {xchg ax,[bp+16] ;Switch old ax and Seg(OldIsr^)}
      $89/$EC/     {mov sp,bp       ;Restore registers}
      $5D/         {pop bp          ;at [bp+0]}
      $07/         {pop es          ;at [bp+2]}
      $1F/         {pop ds          ;at [bp+4]}
      $5F/         {pop di          ;at [bp+6]}
      $5E/         {pop si          ;at [bp+8]}
      $5A/         {pop dx          ;at [bp+10]}
      $59/         {pop cx          ;at [bp+12]}
                   {bx and ax already restored; their slots on the}
                   {stack now have OldIsr, where return will go}
      $CB);        {retf            ;chain to OldIsr}

  procedure Int8(Flags, CS, IP, AX, BX, CX : Word;
                 DX, SI, DI, DS, ES, BP : Word); interrupt;
    {-Interrupt service routine used to monitor stack/heap usage}
  begin
    {make sure we're in the right stack segment}
    if SSeg = OurSS then
      {Flags "parameter" is where SS:SP was when interrupt occurred}
      if Ofs(Flags) < LowestSP then
        LowestSP := Ofs(Flags);

    {compare HeapPtr and HeapHigh, assuming that both pointers
     are normalized}
    if SegOfs(HeapPtr).Segm > SegOfs(HeapHigh).Segm then
      {the segment is higher, so HeapPtr points higher}
      HeapHigh := HeapPtr
    else if SegOfs(HeapPtr).Segm = SegOfs(HeapHigh).Segm then
      {the segment is the same...}
      if SegOfs(HeapPtr).Ofst > SegOfs(HeapHigh).Ofst then
        {and the offset is higher, so HeapPtr points higher}
        HeapHigh := HeapPtr;

    {chain to old INT $8 handler}
    JumpToOldISR(SaveInt8);
  end;

  procedure InstallInt8;
    {-Save INT $8 vector and install our ISR}
  begin
    {make sure we're not already installed, in case we are called
     twice. if we don't do this check, SaveInt8 could get pointed to
     *our* ISR}
    if not Int8Installed then begin
      GetIntVec($8, SaveInt8);
      SetIntVec($8, @Int8);
      Int8Installed := True;
    end;
  end;

  procedure RestoreInt8;
    {-Restore the old INT $8 handler if our ISR is installed}
  begin
    {if we're currently installed, then deinstall}
    if Int8Installed then begin
      SetIntVec($8, SaveInt8);
      Int8Installed := False;
    end;
  end;

  procedure CalcStackUsage(var StackUsage : Word;
                           var HeapUsage : LongInt);
    {-Calculate stack and heap usage}
  begin
    {calculate stack usage}
    StackUsage := InitialSP-LowestSP;

    {total heap usage = (difference in segments * 16) + difference
     in offsets}
    HeapUsage :=
      (LongInt(SegOfs(HeapHigh).Segm-SegOfs(HeapOrg).Segm) * 16) +
       LongInt(SegOfs(HeapHigh).Ofst-SegOfs(HeapOrg).Ofst);
  end;

  procedure ShowStackUsage;
    {-Display stack and heap usage information}
  var
    StackUsage : Word;
    HeapUsage : LongInt;
  begin
    {calculate stack and heap usage}
    CalcStackUsage(StackUsage, HeapUsage);

    {show them}
    WriteLn('Stack usage: ', StackUsage, ' bytes.');
    WriteLn('Heap usage:  ', HeapUsage, ' bytes.');
  end;

  {$F+}  {Exit handlers are always called FAR!}
  procedure OurExitProc;
    {-Deinstalls our INT $8 handler and reports stack/heap usage}
  begin
    {restore ExitProc}
    ExitProc := SaveExitProc;

    {restore INT $8}
    RestoreInt8;

    {show results if desired}
    if ReportStackUsage then
      ShowStackUsage;
  end;
  {$F-}

begin
  {save current value for SS}
  OurSS := SSeg;

  {save current value of SP and account for the return address on
   the stack}
  InitialSP := SPtr+SizeOf(Pointer);
  LowestSP := InitialSP;

  {save current position of HeapPtr}
  HeapHigh := HeapPtr;

  {install our ISR}
  InstallInt8;

  {save ExitProc and install our exit handler}
  SaveExitProc := ExitProc;
  ExitProc := @OurExitProc;
end.